MACD 5 (Alt)/MACD 5.bin/workbench/dir/dum2/src/dum2.mod

Text File | 1987-05-28 | 18.2 KB | 666 lines

MODULE DuM2;

(*      ANOTHER DIRECTORY Utility. This one in Modula-2      *)

(* ALL THE MODULES ARE $A+ SINCE CODE IS NOW ONLY 24800 BYTES OR SO.
   IF IT GROWS A LOT, THEY MAY HAVE TO BE CHANGED TO $Q+
*)

(*$S-*)(*$T-*)(*$A+*)

(*
        This is the main module for DirUtil (works from CLI or WB now)

        Written: 3/21/87 by Greg Browne
        Modified: by Greg Browne
        1.1 - Quicksort added - sized down to 300 files for memory saving
               Clean up booboos. (4/12/87)

        1.2 - EDIT is EXECUTED only, not RUN now & SHOW also - prevents DOS
              from trying to get too many things going at once since when
              RUN is EXEC'ed, it tries the next one immediately.
              Put quotes around filename to allow for multiple word names

        1.3 - Minor clean up (4/15/87)

        1.4 - Added EXEC f-R & EXEC R-f - removed UnARC (redundant)
              Also cleaned up minor message display. (4/18/87)

        1.5 - Added WB Startup  thanks to Richie Bielack's example (4/20/87)
              HAPPY EASTER!

        Compiled on TDI's Modula-2 Compiler version 2.20a


        If you modify this program and change version numbers,
        remember to change the string literal for the window title
        which is located in MAIN control area at end of program.

        You may modify and/or use this program, but please give credit
        where it is due (not only to me, but all the others I drew from)

*)

(*  M2: normal library modules *)

FROM SYSTEM             IMPORT  ADR, NULL,TSIZE,ADDRESS;
FROM Intuition          IMPORT  IDCMPFlagSet,GadgetPtr,IDCMPFlags;
FROM Ports              IMPORT  WaitPort;
FROM Memory             IMPORT  AllocMem,FreeMem,MemReqSet,MemPublic,
                                MemClear;
FROM DOSLibrary         IMPORT  DOSBase;
FROM Libraries          IMPORT  CloseLibrary;
FROM DOSFiles           IMPORT  Lock,Unlock,AccessRead,FileLock,CurrentDir,
                                IoErr,InfoData,Info,CreateDir,DeleteFile,
                                Close,Open,ModeNewFile,FileHandle;
FROM Strings            IMPORT  Concat,Length,Assign,Insert;

(* Richie Bielack's WorkBench startup module *)

FROM WBStart            IMPORT  GetWBStartUpMsg,ReturnWBStartUpMsg;

(* My Du Specific library modules *)

FROM DuWindow           IMPORT  GadgetNames,DuWindowPtr,IOString,DuGads,
                                CloseDuWindow,OpenDuWindow,SlidePot;
FROM DuDir              IMPORT  DirEntries,DirTable,ReadDirectory,QSort,
                                DisplayFiles,NewDir,ClearTable;
FROM DuMisc             IMPORT  CharPtr,MyMsg,MyClass,MyGadPtr,GadGot,
                                MyX,MyY,Gp,CheckMessages,DoFileLook,
                                ReplaceRSDM,StringIt,DuExec,OutHandle,
                                AskForConfirm,DuMoveFile,DuFileTwiddle;

(* Variables not needed in other modules *)

VAR
  Curfirst      : CARDINAL;              (* current first on screen *)
  Curdir,                                (* current dir name        *)
  Reqdir        : ARRAY [0..90] OF CHAR; (* requested dir name      *)
  Entrydirlock,                          (* For later               *)
  Lastdirlock,                           (* Temporary may use later *)
  Curdirlock,                            (* Current directory lock  *)
  Reqdirlock    : FileLock;              (* Requested dir lock      *)
  GpCp          : CharPtr;               (* General purpose pointer *)
  wbmsg         : ADDRESS;               (* WB message if any       *)
  inf           : POINTER TO InfoData;   (* for getting INFO        *)


(* =================================================================*)

(* Little cleanup routine to make sure some junk isn't displayed *)

PROCEDURE RemoveZaps;
VAR i,j:CARDINAL;
BEGIN
  j := 0;
  FOR i := 1 TO DirEntries DO
    IF (DirTable[i]^.FileName[0] = 177C) THEN INC(j) END;
  END;
  IF j > 0 THEN QSort; DEC(DirEntries,j) END;
END RemoveZaps;

(* All the 'ok' and ABORT messages call here to keep a million OK
   and Operation ABORTED constants from being put into the program
*)

PROCEDURE SayOK;
BEGIN
   ReplaceRSDM(msg,"OK");
END SayOK;


PROCEDURE SayAbort;
BEGIN
   ReplaceRSDM(msg,"Operation INTERRUPTED");
END SayAbort;


PROCEDURE EndIt(er:LONGINT);
BEGIN
  IF er = 0 THEN SayOK
   ELSIF er = -1 THEN ReplaceRSDM(msg,"Improper Dest string")
    ELSIF er = -2 THEN SayAbort
     ELSE DisplayError("Couldn't finish",er);
  END;
END EndIt;


PROCEDURE GetReqDir():BOOLEAN;
(* Get directory in Reqdir - or say couldn't by return of FALSE *)
BEGIN
  Reqdirlock := Lock(Reqdir,AccessRead);
  IF (Reqdirlock = 0) THEN RETURN FALSE END;
  IF NOT ReadDirectory(Reqdirlock) THEN
    Unlock(Reqdirlock);
    RETURN FALSE
  ELSE
    IF DirEntries > 1 THEN QSort END;
    NewDir;
    Lastdirlock := CurrentDir(Reqdirlock);
    IF Lastdirlock <> 0 THEN Unlock(Lastdirlock) END;
    Curdirlock := Reqdirlock;
    Assign(Curdir,Reqdir);
    Curfirst := 1;
    RETURN TRUE
  END;
END GetReqDir;


PROCEDURE RedisplayFiles(force:BOOLEAN);
(* If force=TRUE then will be redisplayed anyhow, otherwise only if
   more than a screenfull exist
*)
VAR Vpot : CARDINAL;temp:LONGCARD;
BEGIN
  IF (DirEntries > 15) OR (force) THEN
    Vpot := SlidePot();
    temp := LONGCARD(DirEntries - 15);
    temp := temp * LONGCARD(Vpot);
    Curfirst := CARDINAL(temp DIV 0FFFFH)+1;
    IF Vpot = 0FFFFH THEN Curfirst := 999 END;
    IF Curfirst > DirEntries - 14 THEN Curfirst := DirEntries - 14 END;
    IF Curfirst < 1 THEN Curfirst := 1 END;
    DisplayFiles(Curfirst);
  END;
END RedisplayFiles;


PROCEDURE GetDev;
(* Get the device hit *)
VAR i:CARDINAL;
BEGIN
  GpCp :=CharPtr(DuGads[GadGot].GadgetText^.IText);
  i := 0;
  DEC(GpCp);
  REPEAT
    INC(GpCp);
    Reqdir[i] := GpCp^;
    INC(i);
  UNTIL (GpCp^ = 0C);
  IF GetReqDir() THEN ReplaceRSDM(source,Reqdir) END;
END GetDev;


PROCEDURE GetSource;
VAR i : CARDINAL;
(* Get the IOString[source] directory if possible
   Has several bailout alternatives
*)
BEGIN
  i := 0;
  WHILE (IOString[source][i] > 40C) AND (i < 90) DO
    Reqdir[i] := IOString[source][i];
    INC(i);
  END;
  Reqdir[i] := 0C;
  IF (Reqdir[0] = 0C) THEN Assign(Reqdir,":") END;
  (* If can't get then switch back to currently selected directory *)
  IF NOT GetReqDir() THEN
    DisplayError("Couldn't get requested directory",IoErr());
    Assign(Reqdir,Curdir);
    IF NOT GetReqDir() THEN
      DisplayError("Couldn't switch back - going to ram:",IoErr());
      GadGot := ram;
      GetDev;
    END;
  ReplaceRSDM(source,Curdir);
  END;
  SayOK;
END GetSource;

PROCEDURE GetParent;
(* Go to parent or root depending on the gadget hit and in GadGot *)
VAR i, l:CARDINAL; Stop:BOOLEAN;
BEGIN
  Assign(Reqdir,IOString[source]);
  l := Length(Reqdir);
  Stop := FALSE;
  REPEAT
    DEC(l);
    IF (Reqdir[l] = "/") AND (GadGot = parent) THEN
      Reqdir[l] := 0C; Stop := TRUE;
    ELSIF (Reqdir[l] = ":") THEN
      Reqdir[l+1] := 0C; Stop := TRUE;
    END;
  UNTIL (l=0) OR (Stop);
  IF (Reqdir[0] = 0C) THEN Assign(Reqdir,":") END;
  ReplaceRSDM(source,Reqdir);
  GetSource;
END GetParent;


PROCEDURE SwapStrings(g:GadgetNames);
(* does the shuffling and reselects directory if necessary *)
BEGIN
  IF    g = rtod THEN ReplaceRSDM(dest,  IOString[run]   )
  ELSIF g = rtos THEN ReplaceRSDM(source,IOString[run]   )
  ELSIF g = stod THEN ReplaceRSDM(dest,  IOString[source])
  ELSIF g = stor THEN ReplaceRSDM(run,   IOString[source])
  ELSIF g = dtor THEN ReplaceRSDM(run,   IOString[dest]  )
  ELSIF g = dtos THEN ReplaceRSDM(source,IOString[dest]  )
  ELSIF g = swapsd THEN
        Assign(Gp,IOString[source]);
        ReplaceRSDM(source,IOString[dest]);
        ReplaceRSDM(dest,Gp);
  ELSIF g = swaprd THEN
        Assign(Gp,IOString[run]);
        ReplaceRSDM(run,IOString[dest]);
        ReplaceRSDM(dest,Gp);
  ELSE  Assign(Gp,IOString[source]);  (* swaprs *)
        ReplaceRSDM(source,IOString[run]);
        ReplaceRSDM(run,Gp);
  END;
  CASE g OF
    rtos,
    dtos,
    swaprs,
    swapsd      :   GetSource;          |
  ELSE
  END;
END SwapStrings;


PROCEDURE SelectDir(n:CARDINAL);
(* Select a directory and possibly enter it *)
VAR i,j:CARDINAL;
BEGIN
  FOR i := 1 TO DirEntries DO
    WITH DirTable[i]^ DO
      IF IsDir THEN
        IF i=n THEN
          IsSelected := NOT IsSelected;
        ELSE
          IsSelected := FALSE
        END;
      END;
    END;
  END;
  RedisplayFiles(TRUE);
  IF (DirTable[n]^.IsSelected) THEN
    ReplaceRSDM(msg,"Click it again to ENTER the directory");
    REPEAT (* *) UNTIL CheckMessages();
    j := CARDINAL((MyY - 24) DIV 8) + Curfirst;
    IF (GadGot = filewindow) AND (j = n) THEN
      SayOK;
      Assign(Gp,IOString[source]);
      IF Gp[Length(Gp)-1] <> ":" THEN
        Concat(Gp,"/",Gp);
      END;
      Concat(Gp,DirTable[n]^.FileName,Gp);
      ReplaceRSDM(source,Gp);
      GetSource;
    ELSE
      SayAbort
    END;
  END;
  RedisplayFiles(TRUE);
END SelectDir;


PROCEDURE SelectFile;
(* find, and toggle selection, of a file - branches to SelectDir if
   the hit is over a directory name
*)
VAR pos : CARDINAL;
BEGIN
  pos := CARDINAL((MyY - 24) DIV 8) + Curfirst;
  IF pos <= DirEntries THEN
    WITH DirTable[pos]^ DO
      IF IsDir THEN
        SelectDir(pos)
      ELSE
        IsSelected := NOT IsSelected;
        DisplayFiles(Curfirst);
      END
    END;
  END;
  SayOK;
END SelectFile;


PROCEDURE DisplayError(VAR a:ARRAY OF CHAR; de:LONGINT);
(* display error message with DOS error code *)
VAR v:ARRAY[0..33] OF CHAR; dx:LONGCARD;
BEGIN
  Assign(Gp,a);
  IF de > 0 THEN
    dx := LONGCARD(de);
    Concat(Gp," - DOS error ",Gp);
    IF StringIt(dx,v) THEN END;
    Concat(Gp,v,Gp);
  END;
  ReplaceRSDM(msg,Gp);
END DisplayError;


PROCEDURE SelectAll(v:BOOLEAN);
(* Mass select of all non-directory filenames in the current list
   if v is FALSE it is a mass clear instead
*)
VAR i:CARDINAL;
BEGIN
  FOR i := 1 TO DirEntries DO
    IF DirTable[i]^.IsDir = FALSE THEN DirTable[i]^.IsSelected := v END;
   END;
  DisplayFiles(Curfirst);
  SayOK;
END SelectAll;


PROCEDURE AlreadyGotDest():BOOLEAN;
(* Check to see if the destination path or file exists already
   to prevent rename or makedir of duplicate
*)
VAR l:FileLock;
BEGIN
  l := Lock(IOString[dest],AccessRead);
  IF l <> 0 THEN
    Unlock(l);
    DisplayError("File or directory exists",IoErr());
    RETURN TRUE;
  END;
  RETURN FALSE;
END AlreadyGotDest;


PROCEDURE DoRename;
(* Rename a file [first one found selected] to the dest gadget name
   This routine prevents renaming for CASE changes
   i.e. DOIT.ARC to DoIt.arc - sorry, DOS doesn't care, I do.
*)

VAR i,n:CARDINAL;er:LONGINT;l :FileLock;
BEGIN
  n := 0;i := 0;
  WHILE (n = 0) AND (i < DirEntries) DO
    INC(i);
    IF DirTable[i]^.IsSelected THEN n := i END;
  END;
  IF (n > 0) AND (NOT AlreadyGotDest()) THEN
    er := DuMoveFile(DirTable[i]^.FileName,IOString[dest]);
    IF er = 0 THEN
      GetSource;
      SayOK;
    ELSE
      Insert(" to ",Gp,0);
      Insert(DirTable[i]^.FileName,Gp,0);
      Insert("Couldn't rename ",Gp,0);
      DisplayError(Gp,er);
    END;
  ELSIF (IOString[dest][0] < 41C) THEN
    EndIt(LONGINT(-2))
  END;
END DoRename;


PROCEDURE DeleteDirectory;
(* Delete a directory if not in use or filled
    proposed option is delete even if filled - sort of a mass directory
    kill
*)
VAR i,n:CARDINAL;er:LONGINT;l :FileLock;
BEGIN
  n := 0;i := 0;
  WHILE (n = 0) AND (i < DirEntries) DO
    INC(i);
    IF (DirTable[i]^.IsSelected) AND (DirTable[i]^.IsDir) THEN n := i END;
  END;
  IF (n > 0) THEN
    IF DeleteFile(DirTable[n]^.FileName) THEN
      GetSource;
      SayOK;
    ELSE
      er := IoErr();
      Assign(Gp,DirTable[i]^.FileName);
      IF (er = 216) THEN
        Concat(Gp," not empty",Gp)
      ELSE
        Insert("Couldn't delete ",Gp,0)
      END;
      DisplayError(Gp,er);
    END;
  END;
END DeleteDirectory;

PROCEDURE MakeNewDir;
(* Make new directory if proposed name [dest] not already there
   or if [dest] is not null.  If no full path is given, it will
   make the directory relative to the [source] gadget
*)
VAR l:FileLock;
BEGIN
  IF IOString[dest][0] < 41C THEN
    EndIt(LONGINT(-1))
  ELSIF (NOT AlreadyGotDest()) THEN
    l := CreateDir(IOString[dest]);
    IF (l = 0) THEN
      DisplayError("Couldn't create directory",IoErr());
    ELSE
      Unlock(l);
      SayOK;
      GetSource;
    END;
  END;
END MakeNewDir;

PROCEDURE FillInfo(l:FileLock;VAR s,n:ARRAY OF CHAR);
VAR by:LONGCARD;
BEGIN
  IF (l <> 0) THEN
    IF Info(l,inf^) THEN
      WITH inf^ DO
        IF StringIt((idNumBlocks-idNumBlocksUsed)*idBytesPerBlock,n) THEN END;
        Insert(s,n,0);
        Concat(n," bytes free  ",n);
      END;
    END;
  END;
END FillInfo;

PROCEDURE GiveInfo;
(* Gives info on both source and dest - want to add volume name
   print as well later.
*)
BEGIN
  Gp := "";
  Reqdir := "";
  inf := AllocMem(TSIZE(InfoData),MemReqSet{MemPublic,MemClear});
  IF (inf # NULL) THEN
    FillInfo(Curdirlock,"Source: ",Gp);
    Reqdirlock := Lock(IOString[dest],AccessRead);
    FillInfo(Reqdirlock,"Dest: ",Reqdir);
    IF Reqdirlock <> 0 THEN Unlock(Reqdirlock) END;
    FreeMem(inf,TSIZE(InfoData));
    Concat(Gp,Reqdir,Gp);
    ReplaceRSDM(msg,Gp);
  ELSE
    DisplayError("Couldn't get info block",IoErr());
  END;
END GiveInfo;


PROCEDURE WhatBytes;
(* Show total bytes and files for selected filenames
*)
VAR i,j:CARDINAL;b,f:LONGCARD; v:ARRAY[0..33] OF CHAR;
BEGIN
  f := 0;b := 0;
  FOR i := 1 TO DirEntries DO
    WITH DirTable[i]^ DO
      IF (IsDir = FALSE) AND (IsSelected) THEN
        INC(f);
        b := b + LONGCARD(DirTable[i]^.FileSize) + 512
      END;
    END;
  END;
  IF StringIt(b,v) THEN END;
  Assign(Gp,v);
  Concat(Gp," bytes (incl. FileInfoBlocks) in ",Gp);
  IF StringIt(f,v) THEN END;
  Concat(Gp,v,Gp);
  Concat(Gp," files.",Gp);
  ReplaceRSDM(msg,Gp);
END WhatBytes;


PROCEDURE DoCopy(wcopy,wdel:BOOLEAN);
(* direction handler and exit handler for the Twiddle procedure
   handles COPY, COPYDEL, ZAPFILE, and MOVE
*)
VAR er:LONGINT;
BEGIN
  er := DuFileTwiddle(wcopy,wdel);
  RemoveZaps;
  RedisplayFiles(TRUE);
  EndIt(er);
END DoCopy;


PROCEDURE DoDestruct(g:GadgetNames);
(* Handler for all the destructive stuff
   COPYDEL, ZAPFILE, and DELDIR all go through here to confirm
*)
BEGIN
  AskForConfirm;
  REPEAT (* waiting patiently *) UNTIL CheckMessages();
  IF (GadGot <> g) THEN
    SayAbort;
  ELSE
   IF       g = copydel THEN DoCopy(TRUE,TRUE)
     ELSIF  g = deldir  THEN DeleteDirectory
      ELSIF g = zapfile THEN DoCopy(FALSE,TRUE)
    END;
  END;
END DoDestruct;



(* all GadgetUp messages received in the main routine (LOOP) are sent
   here for processing - further branches handle the various work
*)

PROCEDURE ProcessGadgets(gptr:GadgetPtr):BOOLEAN;
BEGIN

  (* First check for device gadgets since in the GadgetNames, up to vd0
        all are 'get-device' commands *)
  IF GadGot <= vd0 THEN
    GetDev;
    RETURN TRUE;        (* no need to waste time looking at other list *)
  END;

  (* next multiple gadgets using same branch routine
         followed by  gadgets with separate routines  *)

  CASE GadGot OF
    deldir,
    copydel,
    zapfile     : DoDestruct(GadGot);           |
    dtor,
    dtos,
    rtod,
    rtos,
    stor,
    stod,
    swaprd,
    swaprs,
    swapsd      : SwapStrings(GadGot);          |
    arc,
    edit,
    execfr,
    execrf,
    runfr,
    runrf,
    show        : EndIt(DuExec());GetSource;    |
    type,
    htype,
    print,
    hprint      : IF DoFileLook() THEN END;
                  RedisplayFiles(TRUE);         |
    run,
    dest        : RETURN TRUE;                  | (* simply ignore changes *)
    move        : DoCopy(FALSE,FALSE);          |
    makedir     : MakeNewDir;                   |
    filewindow  : SelectFile;                   |
    rename      : DoRename;                     |
    source      : GetSource;                    |
    copy        : DoCopy(TRUE,FALSE);           |
    info        : GiveInfo;                     |
    parent,
    root        : GetParent;                    |
    slider      : RedisplayFiles(FALSE);        |
    select      : SelectAll(TRUE);              |
    clear       : SelectAll(FALSE);             |
    bytes       : WhatBytes;                    |
  ELSE
    ReplaceRSDM(msg,"Sorry, maybe next revision!");
  END;
  RETURN TRUE;
END ProcessGadgets;

(* ---------------------------*)

(* This is the main operating routine.  A double loop is used, although
   a single WaitPort loop would have worked.  Since I wanted a separate
   CheckMessages routine which may have NULL results, I did it this
   way.  Why not?
*)

PROCEDURE GetNextMessage;
BEGIN

            (* Outer loop forces wait for message from intuition *)

 LOOP
  MyMsg := WaitPort(DuWindowPtr^.UserPort);

       (* Inner loop gets messages and processes them until NULL message *)

  LOOP
   IF NOT CheckMessages() THEN EXIT END;
   IF MyClass = IDCMPFlagSet{CloseWindowFlag} THEN
     RETURN     (**** ONLY EXIT so Get out of here ****)
   ELSIF (MyClass = IDCMPFlagSet{GadgetUp}) AND ProcessGadgets(MyGadPtr) THEN
   ELSIF (MyClass = IDCMPFlagSet{ResfreshWindow}) THEN
     RedisplayFiles(TRUE)  (* Rest of screen is self-refreshing *)
   END
  END (* Inner LOOP *)

 END; (* Outer LOOP *)

END GetNextMessage;

                                  (********)
                                  (* MAIN *)
                                  (********)

BEGIN
     wbmsg := GetWBStartUpMsg();
     (* If running from WB then  an output window *)
     IF wbmsg <> NULL THEN
       OutHandle := Open("RAW:0/150/640/49/DuOutputWindow",ModeNewFile)
     ELSE
       OutHandle := FileHandle(0)
     END;
     (* Try to open the window - run if successful [log to ram first] *)
     (* The literal below is the window title bar display             *)

  IF OpenDuWindow("DirUtil v1.5 [TDI Modula-2] - by Greg Browne") THEN
    GadGot := ram;
    GetDev;
    GetNextMessage
  END;
     (* GO HERE ON FAILURE OR FINISH (CloseWindowFlag)               *)
     (* First free the memory used by the DirTable                   *)
  ClearTable;
     (* Close window, graphics library and intuition library if open *)
  CloseDuWindow;
     (* Unlock the directory lock you're holding (if any)            *)
     (* Remember to close DOS library too if open                    *)
  IF Curdirlock <> 0 THEN Unlock(Curdirlock) END;
  IF DOSBase <> 0 THEN CloseLibrary(DOSBase) END;
  IF OutHandle <> 0 THEN Close(OutHandle) END;
  ReturnWBStartUpMsg;
END DuM2.